home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / mouse.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  18.5 KB  |  446 lines
  1. ;-*- Syntax: Zetalisp; Mode: Lisp; Package: BOXER; base: 10; fonts: CPTFONT; -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15.  
  16. ;;;MOUSE(or other pointing thing) tracking stuff
  17.  
  18. (DEFCONST %%KBD-MOUSE-UP-STATE #O1601
  19.   "A byte specifier which determines if a mouse button is being held up or down. ")
  20.  
  21. (DEFVAR *MOUSE-BP* (MAKE-BP :FIXED))
  22.  
  23. (DEFVAR *FOLLOWING-MOUSE-REGION* NIL)
  24.  
  25. (DEFVAR *MOUSE-BUTTONS-CURRENT-STATE* 0
  26.   "Keeps track of which mouse buttons are being held down")
  27.  
  28. (DEFVAR *MOUSE-CLICKS-ONLY* NIL
  29.   "Determines whether the mouse handler will keep track of buttons which are held (not just
  30.    clicked")
  31.  
  32. (DEFVAR *BUTTON-BEING-HELD* NIL
  33.   "The number of the button currently being held down. ")
  34.  
  35. (DEFVAR *MOUSE-SIGNAL-HOLD-TIME* 400000.
  36.   "The amount of time (in microseconds) a mouse button must be held down to signal that it is being held and not clicked. ")
  37.  
  38. (DEFVAR *MOUSE-DISAPPEARING-TIMEOUT* 120.
  39.   "The amount of time in 60ths of a second that a mouse will wait before disappearing.")
  40.  
  41. (DEFVAR *MOUSE-BOX-X* 0.
  42.   "The X position of the mouse in coordinates based on the upper left hand corner of the
  43. lowest Box which contains the Mouse.")
  44.  
  45. (DEFVAR *MOUSE-BOX-Y* 0.
  46.   "The Y position of the mouse in coordinates based on the upper left hand corner of the
  47. lowest Box which contains the Mouse.")
  48.  
  49. (DEFSUBST VISIBLE-NAME-ROW? (SCREEN-BOX)
  50.   (AND (TELL (TELL SCREEN-BOX :ACTUAL-OBJ) :NAME-ROW)
  51.        (NEQ (OUTERMOST-SCREEN-BOX) SCREEN-BOX)))
  52.  
  53. (DEFSUBST SCREEN-BOXES-IN-ROW (SCREEN-ROW)
  54.   (SUBSET #'SCREEN-BOX? (TELL SCREEN-ROW :INFERIORS)))
  55.  
  56. (DEFSUBST POSITION-IN-SCREEN-OBJ? (X Y SCREEN-OBJ)
  57.   (AND (INCLUSIVE-BETWEEN? Y 0 (SCREEN-OBJ-HEI SCREEN-OBJ))
  58.        (OR (SCREEN-ROW? SCREEN-OBJ)
  59.        (INCLUSIVE-BETWEEN? X 0 (SCREEN-OBJ-WID SCREEN-OBJ)))))
  60.  
  61. (DEFUN FIND-INF-SCREEN-BOX-IN-SUP-SCREEN-ROW (X Y SCREEN-BOXES)
  62.   (LOOP FOR SCREEN-BOX IN SCREEN-BOXES
  63.     FOR RELATIVE-X = (- X (SCREEN-OBJ-X-OFFSET SCREEN-BOX))
  64.     FOR RELATIVE-Y = (- Y (SCREEN-OBJ-Y-OFFSET SCREEN-BOX))
  65.     WHEN (POSITION-IN-SCREEN-OBJ? RELATIVE-X RELATIVE-Y SCREEN-BOX)
  66.     RETURN SCREEN-BOX))
  67.  
  68. (DEFUN GET-CHA-NO (X LIST-OF-CHAS)
  69.   (LOOP FOR SCREEN-CHA IN LIST-OF-CHAS
  70.     SUM (SCREEN-OBJECT-WIDTH SCREEN-CHA) INTO ACC-WID
  71.     COUNT T INTO CHA-NO
  72.     WHEN ( ACC-WID X)
  73.     RETURN (1- CHA-NO)
  74.     FINALLY (RETURN (LENGTH LIST-OF-CHAS))))
  75.  
  76. (DEFMETHOD (SCREEN-ROW :FIND-BP-VALUES) (SUPERIOR-X SUPERIOR-Y)
  77.   (LET* ((X (- SUPERIOR-X X-OFFSET))
  78.      (Y (- SUPERIOR-Y Y-OFFSET))
  79.      (WITHIN-BOX (FIND-INF-SCREEN-BOX-IN-SUP-SCREEN-ROW X Y (SCREEN-BOXES-IN-ROW SELF))))
  80.     (IF (NULL WITHIN-BOX)
  81.     (VALUES ACTUAL-OBJ (GET-CHA-NO X SCREEN-CHAS) SCREEN-BOX SUPERIOR-X SUPERIOR-Y)
  82.     (TELL WITHIN-BOX :FIND-BP-VALUES X Y))))
  83.  
  84. (DEFMETHOD (SCREEN-BOX :GET-AREA-OF-BOX) (X Y)
  85.   "Returns the part of the box which (X, Y) is pointing to which can be a SCREEN-ROW,
  86. or one of the following keywords :NAME, :UNDERNAME, :LAST or NIL if (X, Y) is not inside
  87. a portion of the box. "
  88.   (MULTIPLE-VALUE-BIND (IL IT IR IB)
  89.       (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  90.     (COND ((AND (EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK)
  91.         (INCLUSIVE-BETWEEN? X IL (- WID IR))
  92.         (INCLUSIVE-BETWEEN? Y (// IT 2) (- HEI IB)))
  93.        :INSIDE)
  94.       ((AND (INCLUSIVE-BETWEEN? X IL (- WID IR))
  95.         (INCLUSIVE-BETWEEN? Y IT (- HEI IB)))
  96.        ;; Pointing to main area of box (where the screen rows are)
  97.        (IF (#+SYMBOLICS LISTP #-SYMBOLICS CONSP SCREEN-ROWS)
  98.            (FIND-INF-SCREEN-ROW-IN-SUP-SCREEN-BOX X Y SCREEN-ROWS)
  99.            ':INSIDE))
  100.       ((AND (INCLUSIVE-BETWEEN? X IL (- WID IR))
  101.         (INCLUSIVE-BETWEEN? Y (// IT 2) IT))
  102.        :TOP)
  103.       ((VISIBLE-NAME-ROW? SELF)
  104.        ;; must be pointing somewhere else
  105.        (MULTIPLE-VALUE-BIND (TAB-FULL-WID TAB-FULL-HEI)
  106.            (SCREEN-BOX-BORDERS-FN ':TAB-SPACE SELF)
  107.          (MULTIPLE-VALUE-BIND (TAB-X TAB-Y)
  108.          (SCREEN-BOX-BORDERS-FN ':TAB-OFFSETS SELF)
  109.            (COND ((AND (< X TAB-FULL-WID) (> Y TAB-FULL-HEI)) :UNDERNAME)
  110.              ((AND (INCLUSIVE-BETWEEN? X TAB-X TAB-FULL-WID)
  111.                (INCLUSIVE-BETWEEN? Y TAB-Y TAB-FULL-HEI)) :NAME))))))))
  112.  
  113. (DEFMETHOD (GRAPHICS-SCREEN-BOX :GET-AREA-OF-BOX) (X Y)
  114.   (MULTIPLE-VALUE-BIND (IL IT IR IB)
  115.       (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  116.     (COND ((AND (INCLUSIVE-BETWEEN? X IL (- WID IR))
  117.         (INCLUSIVE-BETWEEN? Y (// IT 2) (- HEI IB)))
  118.        ;; Pointing to main area of box (where the graphics sheet is)
  119.        :INSIDE)
  120.       ((AND (INCLUSIVE-BETWEEN? X IL (- WID IR))
  121.         (INCLUSIVE-BETWEEN? Y (// IT 2) IT))
  122.        :TOP)
  123.       ((VISIBLE-NAME-ROW? SELF)
  124.        ;; must be pointing somewhere else
  125.        (MULTIPLE-VALUE-BIND (TAB-FULL-WID TAB-FULL-HEI)
  126.            (SCREEN-BOX-BORDERS-FN ':TAB-SPACE SELF)
  127.          (MULTIPLE-VALUE-BIND (TAB-X TAB-Y)
  128.          (SCREEN-BOX-BORDERS-FN ':TAB-OFFSETS SELF)
  129.            (COND ((AND (< X TAB-FULL-WID) (> Y TAB-FULL-HEI)) :UNDERNAME)
  130.              ((AND (INCLUSIVE-BETWEEN? X TAB-X TAB-FULL-WID)
  131.                (INCLUSIVE-BETWEEN? Y TAB-Y TAB-FULL-HEI)) :NAME))))))))
  132.  
  133. (DEFUN FIND-INF-SCREEN-ROW-IN-SUP-SCREEN-BOX (X Y SCREEN-ROWS)
  134.   (LOOP FOR SCREEN-ROW IN SCREEN-ROWS
  135.     FOR RELATIVE-X = (- X (SCREEN-OBJ-X-OFFSET SCREEN-ROW))
  136.     FOR RELATIVE-Y = (- Y (SCREEN-OBJ-Y-OFFSET SCREEN-ROW))
  137.     WHEN (POSITION-IN-SCREEN-OBJ? RELATIVE-X RELATIVE-Y SCREEN-ROW)
  138.     RETURN SCREEN-ROW
  139.     FINALLY (RETURN :LAST)))
  140.  
  141. (DEFMETHOD (SCREEN-BOX :FIND-BP-VALUES)
  142.        (SUPERIOR-X SUPERIOR-Y &OPTIONAL (WINDOW *BOXER-PANE*))
  143.   (LET* ((X (- SUPERIOR-X X-OFFSET))
  144.      (Y (- SUPERIOR-Y Y-OFFSET))
  145.          (WITHIN-AREA (TELL SELF :GET-AREA-OF-BOX X Y)))
  146.     (COND ((AND (EQ SELF (OUTERMOST-SCREEN-BOX WINDOW)) (NULL WITHIN-AREA))
  147.        (MULTIPLE-VALUE-BIND (ROW CHA-NO)
  148.            (BOX-FIRST-BP-VALUES ACTUAL-OBJ)
  149.          (VALUES ROW CHA-NO SELF X Y)))
  150.       ((NULL WITHIN-AREA)
  151.        (MULTIPLE-VALUE-BIND (ROW CHA-NO)
  152.            (BOX-SELF-BP-VALUES ACTUAL-OBJ)
  153.          (VALUES ROW CHA-NO SUPERIOR-SCREEN-BOX
  154.              (+ (SCREEN-OBJ-X-OFFSET SCREEN-ROW) SUPERIOR-X)
  155.              (+ (SCREEN-OBJ-Y-OFFSET SCREEN-ROW) SUPERIOR-Y))))
  156.       ((SCREEN-ROW? WITHIN-AREA)
  157.        (TELL WITHIN-AREA :FIND-BP-VALUES X Y))
  158.       ((EQ WITHIN-AREA :LAST)
  159.        (TELL (CAR (LAST SCREEN-ROWS)) :FIND-BP-VALUES X Y))
  160.       ((EQ WITHIN-AREA :INSIDE)
  161.        (MULTIPLE-VALUE-BIND (ROW CHA-NO)
  162.            (BOX-FIRST-BP-VALUES ACTUAL-OBJ)
  163.          (VALUES ROW CHA-NO SELF X Y)))
  164.       ((EQ WITHIN-AREA :TOP)
  165.        (MULTIPLE-VALUE-BIND (ROW CHA-NO)
  166.            (BOX-FIRST-BP-VALUES ACTUAL-OBJ)
  167.          (VALUES ROW CHA-NO SELF X Y)))
  168.       ((EQ WITHIN-AREA :UNDERNAME)
  169.        (MULTIPLE-VALUE-BIND (ROW CHA-NO)
  170.            (BOX-SELF-BP-VALUES ACTUAL-OBJ)
  171.          (VALUES ROW CHA-NO SUPERIOR-SCREEN-BOX
  172.              (+ (SCREEN-OBJ-X-OFFSET SCREEN-ROW) SUPERIOR-X)
  173.              (+ (SCREEN-OBJ-Y-OFFSET SCREEN-ROW) SUPERIOR-Y))))
  174.       ((EQ WITHIN-AREA :NAME)
  175.        (LET ((NAME-ROW (TELL ACTUAL-OBJ :NAME-ROW)))
  176.          (VALUES NAME-ROW (GET-CHA-NO X (TELL NAME-ROW :CHAS)) SELF X Y)))
  177.       (T (FERROR "Can't find a place in ~A for position ~D, ~D" SELF X Y)))))
  178.  
  179. (DEFUN SCREEN-OBJ-AT-POSITION (X Y &OPTIONAL (WINDOW *BOXER-PANE*))
  180.   "Throws back a ROW, CHA-NO, SCREEN-BOX and a position relative to the SCREEN-BOX based on
  181. the present location of the mouse. "
  182.   (LET ((SUPERIOR-X (TV:SHEET-INSIDE-LEFT WINDOW))
  183.     (SUPERIOR-Y (TV:SHEET-INSIDE-TOP WINDOW))
  184.     (SCREEN-OBJ (OUTERMOST-SCREEN-BOX WINDOW)))    
  185.     (CHECK-SCREEN-OBJ-ARG SCREEN-OBJ)
  186.     (WITH-FONT-MAP-BOUND (*BOXER-PANE*)
  187.       (TELL SCREEN-OBJ :FIND-BP-VALUES (- X SUPERIOR-X) (- Y SUPERIOR-Y) WINDOW))))
  188.  
  189. ;;; This shouldn't be consing up a BP every time ....
  190. (DEFMACRO WITH-MOUSE-BP-BOUND ((X Y WINDOW) &BODY BODY)
  191.   "This macro sets up an environment where MOUSE-BP is bound to a BP which indicates
  192. where in the actual structure the mouse is pointing to.  MOUSE-SCREEN-BOX is also
  193. bound to the screen box which the mouse is pointing to. "
  194.   `(LET ((MOUSE-BP (MAKE-BP ':FIXED)))
  195.      (MULTIPLE-VALUE-BIND (MOUSE-ROW MOUSE-CHA-NO MOUSE-SCREEN-BOX)
  196.      (SCREEN-OBJ-AT-POSITION ,X ,Y ,WINDOW)
  197.      (UNWIND-PROTECT
  198.        (PROGN
  199.      (SET-BP-ROW MOUSE-BP MOUSE-ROW)
  200.      (SET-BP-CHA-NO MOUSE-BP MOUSE-CHA-NO)
  201.      (SET-BP-SCREEN-BOX MOUSE-BP MOUSE-SCREEN-BOX)
  202.      . ,BODY)
  203.        (TELL-CHECK-NIL (BP-ROW MOUSE-BP) :DELETE-BP MOUSE-BP)))))
  204.  
  205. (DEFMETHOD (BOXER-PANE :WHO-LINE-DOCUMENTATION-STRING) ()
  206.   (IF (TELL-CHECK-NIL *SPRITE-BLINKER* :SELECTED-SPRITE)
  207.       (LET ((WHO-LINE
  208.           (TELL-CHECK-NIL
  209.         (CDR (TELL-CHECK-NIL (SEND (SEND *SPRITE-BLINKER* :SELECTED-SPRITE)
  210.                        :SPRITE-BOX)
  211.                      :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY 'BU:WHO-LINE))
  212.         :TEXT-STRING)))
  213.     (OR WHO-LINE "  ** Sprite-defined-clicks **  "))
  214.       WHO-LINE-DOCUMENTATION-STRING))
  215.  
  216. ;;;; BOXER Mouse handlers
  217.  
  218. ;;; the (default) simple ones that we know will work
  219.  
  220. (DEFUN DEFAULT-MOUSE-ENTERS-WINDOW-HANDLER (WINDOW)
  221.   ;; For now, just make the mouse blinker be an ordinary arrow,
  222.   ;; and let tv:mouse-default-handler track it.
  223.   (TV:MOUSE-STANDARD-BLINKER WINDOW)
  224.   (TV:MOUSE-DEFAULT-HANDLER WINDOW NIL))
  225.  
  226. (DEFUN DEFAULT-MOUSE-MOVES-HANDLER (WINDOW X Y)
  227.   ;; For now, in conjunction with the fact that the default
  228.   ;; mouse-enters-window-handler makes the mouse blinker be
  229.   ;; an ordinary arrow, just make the mouse blinker follow
  230.   ;; the mouse.
  231.   (TV:MOUSE-SET-BLINKER-CURSORPOS)
  232.   (MULTIPLE-VALUE-BIND (IGNORE IGNORE SCREEN-BOX IGNORE IGNORE)
  233.       (SCREEN-OBJ-AT-POSITION X Y WINDOW)
  234.     (IF (GRAPHICS-SCREEN-BOX? SCREEN-BOX)
  235.     (TELL SCREEN-BOX :HIGHLIGHT-SPRITE-UNDER-MOUSE X Y)
  236.     (TELL *SPRITE-BLINKER* :OFF))))
  237.  
  238. (DEFUN DEFAULT-MOUSE-CLICK-HANDLER (WINDOW CLICK X Y)
  239.   ;; Get this out of the mouse process as quickly as possible.
  240.   (TV:IO-BUFFER-CLEAR (TELL WINDOW :IO-BUFFER))
  241.   (TELL WINDOW :FORCE-KBD-INPUT `(:MOUSE-CLICK ,WINDOW ,CLICK ,X ,Y)))
  242.  
  243. (DEFUN DEFAULT-MOUSE-BUTTONS-HANDLER (WINDOW BD X Y)
  244.   (TELL WINDOW :MOUSE-CLICK (TV:MOUSE-BUTTON-ENCODE BD) X Y))
  245.  
  246. ;;; the fancy ones that might NOT work
  247.  
  248. (DEFUN FANCY-MOUSE-MOVES-HANDLER (WINDOW X Y)
  249.   ;; keep the blinker in the right place
  250.   (TV:MOUSE-SET-BLINKER-CURSORPOS)
  251.   ;; bind some useful values
  252.   (MULTIPLE-VALUE-BIND (MROW MCHA-NO MSCREEN-BOX RELX RELY)
  253.       (SCREEN-OBJ-AT-POSITION X Y WINDOW)
  254.     (UNLESS (OR (NULL MROW)
  255.         (AND (EQ MROW        (BP-ROW *MOUSE-BP*))
  256.              (=  MCHA-NO     (BP-CHA-NO *MOUSE-BP*))
  257.              (EQ MSCREEN-BOX (BP-SCREEN-BOX *MOUSE-BP*))))
  258.       (MOVE-BP-1 *MOUSE-BP* MROW MCHA-NO)
  259.       (SET-BP-SCREEN-BOX *MOUSE-BP* MSCREEN-BOX)
  260.       ;; if the mouse is in the middle of defining a region, then update the region
  261.       (TELL-CHECK-NIL (SYMEVAL-GLOBALLY '*FOLLOWING-MOUSE-REGION*)
  262.               :UPDATE-REDISPLAY-ALL-ROWS))
  263.     (IF (GRAPHICS-SCREEN-BOX? MSCREEN-BOX)
  264.     (TELL MSCREEN-BOX :HIGHLIGHT-SPRITE-UNDER-MOUSE X Y)
  265.     (TELL *SPRITE-BLINKER* :OFF))
  266.     (SETQ *MOUSE-BOX-X* RELX)
  267.     (SETQ *MOUSE-BOX-Y* RELY)))
  268.  
  269. ;;; these handlers get compiled in the TV package because they use LOTS of variables from
  270. ;;; that package.
  271.  
  272. (DEFUN DONT-HIDE-THE-MOUSE-YET ()
  273.   (OR (NOT (NULL  (TELL *SPRITE-BLINKER* :SELECTED-SPRITE)))
  274.       TV:MOUSE-RECONSIDER
  275.       TV:MOUSE-WAKEUP))
  276.  
  277. TV:
  278. (DEFUN BOXER:FANCY-MOUSE-ENTERS-WINDOW-HANDLER (WINDOW &AUX HAND)
  279.   (MOUSE-STANDARD-BLINKER WINDOW)
  280.   (MULTIPLE-VALUE-BIND (WINDOW-X-OFFSET WINDOW-Y-OFFSET)
  281.       (SHEET-CALCULATE-OFFSETS WINDOW MOUSE-SHEET)
  282.     (LET ((MOUSE-VISIBLE-P T))
  283.       (LOOP FOR HIDE-MOUSE = (NOT (PROCESS-WAIT-WITH-TIMEOUT
  284.                       "Mouse Timeout" BOXER:*MOUSE-DISAPPEARING-TIMEOUT*
  285.                     #'BOXER:DONT-HIDE-THE-MOUSE-YET))
  286.         UNTIL (OR MOUSE-RECONSIDER (NEQ WINDOW (WINDOW-OWNING-MOUSE)))
  287.           ;; give other things a chance to break in
  288.         DO (PROCESS-SLEEP 1.)
  289.         WHEN (AND HIDE-MOUSE MOUSE-VISIBLE-P (NULL BOXER:*BUTTON-BEING-HELD*))
  290.           ;; the mouse is visible but we've waited the requisite amount of time and no one
  291.           ;; has touched the mouse so we turn the blinker off
  292.           DO (WITHOUT-INTERRUPTS
  293.            (SEND MOUSE-BLINKER :SET-CHARACTER #-TI #\SPACE #+TI #\@)    ;should be an invisible char
  294.            (SEND MOUSE-BLINKER :TRACK-MOUSE)
  295.            (SETQ MOUSE-VISIBLE-P NIL))
  296.         WHEN (AND (NULL MOUSE-VISIBLE-P) (NULL HIDE-MOUSE))
  297.           ;; the mouse has been moved but the blinker is currently off so
  298.           ;; we turn it back on and warp it to the current location of the cursor
  299.           DO (WITHOUT-INTERRUPTS
  300.            (MOUSE-STANDARD-BLINKER WINDOW)
  301.            (MULTIPLE-VALUE-BIND (TARGET-X TARGET-Y)
  302.                (SHEET-CALCULATE-OFFSETS BOXER:*BOXER-PANE* MOUSE-SHEET)
  303.              (MOUSE-WARP (+ (SEND BOXER:*BOXER-PANE* :CURSOR-X) TARGET-X)
  304.                  (+ (SEND BOXER:*BOXER-PANE* :CURSOR-Y) TARGET-Y)))
  305.            (SETQ MOUSE-VISIBLE-P T))
  306.         WHEN (NULL HIDE-MOUSE)
  307.           DO 
  308.         (MULTIPLE-VALUE-BIND (DX DY BD BU X Y)
  309.             (MOUSE-INPUT NIL)
  310.           DX DY
  311.           (LET ((WINDOW-X (- X WINDOW-X-OFFSET))
  312.             (WINDOW-Y (- Y WINDOW-Y-OFFSET)))
  313.             (COND ((AND (PLUSP BD)
  314.                 BOXER:(OR *MOUSE-CLICKS-ONLY*
  315.                       (NULL *BUTTON-BEING-HELD*)))
  316.                (SEND WINDOW :MOUSE-BUTTONS BD WINDOW-X WINDOW-Y))
  317.               ((AND (NULL BOXER:*MOUSE-CLICKS-ONLY*)
  318.                 (BOXER:NOT-NULL BOXER:*BUTTON-BEING-HELD*)
  319.                 (PLUSP BU))
  320.                (SEND WINDOW :MOUSE-BUTTONS BU WINDOW-X WINDOW-Y))
  321.               (T
  322.                (SEND WINDOW :MOUSE-MOVES WINDOW-X WINDOW-Y)
  323.                         ;(MOUSE-SET-BLINKER-CURSORPOS)
  324.                ))
  325.             ;; Now process button pushes if mouse is not seized
  326.             (COND ((OR (ZEROP BD) (EQ WINDOW T) (WINDOW-OWNING-MOUSE)))
  327.               ;; Default action for left button is to select what mouse is pointing at
  328.               ((BIT-TEST 1 BD)
  329.                (AND (SETQ HAND (WINDOW-UNDER-MOUSE ':MOUSE-SELECT ':ACTIVE X Y))
  330.                 ;; Next line temporarily papers over a bug with :MOUSE-SELECT
  331.                 (GET-HANDLER-FOR HAND ':SELECT)
  332.                 (MOUSE-SELECT HAND)))
  333.               ;; Default action for middle button is to switch to the main screen
  334.               ((BIT-TEST 2 BD)
  335.                (IF (TYPEP MOUSE-SHEET 'SCREEN)
  336.                    (PROCESS-RUN-FUNCTION "Set mouse sheet"
  337.                  #'MOUSE-SET-SHEET DEFAULT-SCREEN)))
  338.               ;; Default action for right button is to call the system menu
  339.               ((BIT-TEST 4 BD)
  340.                (MOUSE-BUTTON-ENCODE BD)    ;Satisfy those who double-click out of habit
  341.                (MOUSE-CALL-SYSTEM-MENU)))))))))
  342.  
  343. #+TI(DEFVAR TV:*MOUSE-MODIFYING-KEYSTATES* '(:CONTROL :META :SUPER :HYPER))
  344. #+TI(EVAL-WHEN (LOAD) (SETQ TV:*MOUSE-INCREMENTING-KEYSTATES* '(:SHIFT)))
  345.  
  346. TV:
  347. (DEFUN BOXER:FANCY-MOUSE-BUTTONS-HANDLER (WINDOW BD X Y)
  348.   (LET ((BUTTON (1- (HAULONG BD))))    ;Pick a button that was just pushed
  349.     (UNLESS (MINUSP BUTTON)        ;Check whether a button was in fact pushed
  350.       (LET ((MASK (LSH 1 BUTTON))
  351.         (CH (DPB 1 %%KBD-MOUSE BUTTON))
  352.         (TIME MOUSE-LAST-BUTTONS-TIME)
  353.         NEW-BUTTONS NEW-TIME)
  354.     ;; See whether we got a "double" click via the keyboard
  355.     (DOLIST (KEY *MOUSE-INCREMENTING-KEYSTATES*)
  356.       (WHEN (KEY-STATE KEY)
  357.         (SETQ CH (DPB 1 %%KBD-MOUSE-N-CLICKS CH))
  358.         (RETURN)))
  359.     ;; Add in any control bits from the keyboard
  360.     (DOLIST (KEY *MOUSE-MODIFYING-KEYSTATES*)
  361.       (WHEN (KEY-STATE KEY)
  362.         (SETQ CH (DPB 1 (SYMEVAL (CDR (ASSQ KEY '((:CONTROL . %%KBD-CONTROL)
  363.                               (:META . %%KBD-META)
  364.                               (:SUPER . %%KBD-SUPER)
  365.                               (:HYPER . %%KBD-HYPER)))))
  366.               CH))))
  367.     ;; De-bounce mouse and look for double clicks
  368.     (LOOP NAMED DEBOUNCE DOING  ;Do forever (until guy's finger wears out)
  369.       ;; Ignore any clicking during the bounce delay
  370.       (LOOP DOING (MULTIPLE-VALUE (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
  371.         UNTIL (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-BOUNCE-TIME)
  372.         FINALLY (SETQ TIME NEW-TIME))
  373.       (WHEN (AND (NOT BOXER:*MOUSE-CLICKS-ONLY*) BOXER:*BUTTON-BEING-HELD*)
  374.         ;; a held down button was raised
  375.         (IF ( CH BOXER:*BUTTON-BEING-HELD*)
  376.         (SETQ BOXER:*BUTTON-BEING-HELD* NIL)    ;wrong button was raised
  377.         (SEND WINDOW :MOUSE-HOLD (DPB 1 BOXER:%%KBD-MOUSE-UP-STATE CH) X Y)
  378.         (SETQ BOXER:*BUTTON-BEING-HELD* NIL))
  379.         (RETURN))                
  380.       (WHEN (AND BOXER:*MOUSE-CLICKS-ONLY* (NULL MOUSE-DOUBLE-CLICK-TIME))
  381.         ;; Double-click feature disabled
  382.         (RETURN))
  383.       ;; Look for button to be lifted, or for double-click timeout
  384.       (LOOP WHILE (BIT-TEST MASK NEW-BUTTONS)
  385.         DO (MULTIPLE-VALUE (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
  386.         WHEN (AND (NOT BOXER:*MOUSE-CLICKS-ONLY*)
  387.               (> (TIME-DIFFERENCE NEW-TIME TIME) BOXER:*MOUSE-SIGNAL-HOLD-TIME*))
  388.           ;; Timed-out with button still down so we assume it is being HELD down
  389.           DO (SEND WINDOW :MOUSE-HOLD CH X Y)
  390.              (SETQ BOXER:*BUTTON-BEING-HELD* CH)
  391.              (RETURN-FROM DEBOUNCE)
  392.         FINALLY (SETQ TIME NEW-TIME))
  393.       (WHEN (NULL MOUSE-DOUBLE-CLICK-TIME)
  394.         (RETURN))            ;Double clicks disabled AND we checked for button hold
  395.       ;; Button was lifted, do another bounce delay
  396.       (LOOP DOING (MULTIPLE-VALUE (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
  397.         UNTIL (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-BOUNCE-TIME)
  398.         FINALLY (SETQ TIME NEW-TIME))
  399.       ;; Now watch for button to be pushed again
  400.       (LOOP UNTIL (BIT-TEST MASK NEW-BUTTONS)
  401.         DO (MULTIPLE-VALUE (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
  402.         WHEN (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-DOUBLE-CLICK-TIME)
  403.           ;; Timed-out with button still up
  404.           DO (SEND WINDOW :MOUSE-CLICK CH X Y)
  405.              (RETURN-FROM DEBOUNCE)
  406.         FINALLY (SETQ CH (+ CH 8)    ;Count multiplicity of clicks
  407.                   TIME NEW-TIME))
  408.       ;; Continue scanning (for triple click)
  409.       )
  410.     ;; Save state for next time
  411.     (SETQ MOUSE-LAST-BUTTONS NEW-BUTTONS
  412.           MOUSE-LAST-BUTTONS-TIME NEW-TIME)
  413.     T))))
  414.  
  415. ;;; Interface into the window system (maybe should be in BOXWIN).
  416. ;;; They are NOT normal window messages (like :MOUSE-CLICK) since other windows besides the
  417. ;;; BOXER-PANE don't handle them
  418.  
  419. ;;; at some point, add another level of abstraction here like the other mouse handlers
  420. ;;; but it doesn't seem worth it right now
  421.  
  422. (DEFMETHOD (BOXER-PANE :MOUSE-HOLD) (BUTTONS X Y)
  423.   (TV:IO-BUFFER-CLEAR (TELL SELF :IO-BUFFER))
  424.   (TELL SELF :FORCE-KBD-INPUT `(:MOUSE-HOLD ,SELF ,BUTTONS ,X ,Y)))
  425.  
  426. ;;;; how to switch back and forth
  427.  
  428. (DEFUN FANCY-MOUSE-HANDLERS ()
  429.   (WHEN (FDEFINEDP 'FANCY-MOUSE-MOVES-HANDLER)
  430.     (SET-MOUSE-MOVES-HANDLER 'FANCY-MOUSE-MOVES-HANDLER))
  431.   (WHEN (FDEFINEDP 'FANCY-MOUSE-CLICK-HANDLER)
  432.     (SET-MOUSE-CLICK-HANDLER 'FANCY-MOUSE-CLICK-HANDLER))
  433.   (WHEN (FDEFINEDP 'FANCY-MOUSE-ENTERS-WINDOW-HANDLER)
  434.     (SET-MOUSE-ENTERS-WINDOW-HANDLER 'FANCY-MOUSE-ENTERS-WINDOW-HANDLER))
  435.   (WHEN (FDEFINEDP 'FANCY-MOUSE-BUTTONS-HANDLER)
  436.     (SET-MOUSE-BUTTONS-HANDLER 'FANCY-MOUSE-BUTTONS-HANDLER))
  437.   (SETQ *MOUSE-CLICKS-ONLY* NIL)
  438.   T)
  439.  
  440. (DEFUN RESET-MOUSE-HANDLERS ()
  441.   (SET-MOUSE-MOVES-HANDLER 'DEFAULT-MOUSE-MOVES-HANDLER)
  442.   (SET-MOUSE-CLICK-HANDLER 'DEFAULT-MOUSE-CLICK-HANDLER)
  443.   (SET-MOUSE-ENTERS-WINDOW-HANDLER 'DEFAULT-MOUSE-ENTERS-WINDOW-HANDLER)
  444.   (SET-MOUSE-BUTTONS-HANDLER 'DEFAULT-MOUSE-BUTTONS-HANDLER)
  445.   T)
  446.